home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGSCAL / TBUTIL1.LZH / SORT.PAS < prev    next >
Pascal/Delphi Source File  |  1983-03-08  |  5KB  |  212 lines
  1. {$debug-}
  2.  
  3. program sort (output,infile,outfile);
  4.  
  5. function allhqq (size: word) : word;
  6.   external;
  7.   
  8. procedure endxqq;
  9.   external;
  10.  
  11. var
  12.   infile, outfile : text;
  13.   p               : array [wrd(1)..4000] of adrmem;
  14.   ptr             : adrmem;
  15.   inline          : lstring (255);
  16.   max_p           : word;
  17.   lines_in        : word;
  18.   
  19. procedure read_in;
  20.   var [static]
  21.     i      : word;
  22.     offwrd : word;
  23.     offadr : adrmem;
  24.     inladr : adrmem;
  25.   begin
  26.     inladr := adr inline;
  27.     write   ('Reading...     ');
  28.     reset (infile);
  29.     lines_in := 0;
  30.     while not eof (infile) do
  31.       begin
  32.         readln (infile,inline);
  33.         if inline.len >  80 then
  34.            inline.len := 80;
  35.         for i := inline.len downto 1 do
  36.           if inline [i] = ' ' then
  37.             inline.len := inline.len - 1
  38.           else
  39.             break;
  40.         lines_in := lines_in + 1;
  41.         write (chr(8),chr(8),chr(8),chr(8),chr(8),lines_in:5);
  42.         offwrd   := allhqq (inline.len + 1);
  43.         offadr   := retype (adrmem,offwrd);
  44.         if (offwrd < 2) or (lines_in > 4000) then
  45.           begin
  46.             lines_in := lines_in - 1;
  47.             writeln;
  48.             writeln ('Error! Too many index lines to sort in memory, ',
  49.                      'sorting only the first',lines_in:5);
  50.             writeln;
  51.             return;
  52.           end;
  53.         p [lines_in] := offadr;
  54.         for i := 0 to inline.len do
  55.           offadr^[i] := inladr^[i];        
  56.       end;
  57.     close (infile);
  58.     writeln (' index entries read.');
  59.   end;
  60.   
  61. procedure sort_data;
  62.   var [static]
  63.     done : boolean;
  64.     i    : word;
  65.     j    : word;
  66.     last : word;
  67.     pass : word;
  68.     w    : integer;
  69.     
  70.     function to_switch : boolean;
  71.       var [static]
  72.         ii,jj : lstring (80);
  73.         ip,jp : adrmem;
  74.         k     : word;
  75.         last  : word;
  76.         temp  : byte;
  77.       begin
  78.         if i = 1 then
  79.           begin
  80.             ip := p [i];
  81.             ii.len := ip^[0];
  82.             for k := 1 to ii.len do
  83.               begin
  84.                 temp := ip^[k];
  85.                 if temp < 91 then
  86.                   if temp > 64 then
  87.                     temp := temp + 32;
  88.                 ii [k] := chr (temp);
  89.               end;
  90.           end;
  91.         jp := p [j];
  92.         jj.len := jp^[0];
  93.         for k := 1 to jj.len do
  94.           begin
  95.             temp := jp^[k];
  96.             if temp < 91 then
  97.               if temp > 64 then
  98.                 temp := temp + 32;
  99.             jj [k] := chr (temp);
  100.           end;
  101.         if ii.len > jj.len then
  102.           last := jj.len
  103.         else
  104.           last := ii.len;
  105.         if last < 8 then
  106.           begin
  107.             to_switch := false;
  108.             ii := jj;
  109.             return;
  110.           end;
  111.         for k := 8 to last do
  112.           begin
  113.             if ii [k] < jj [k] then
  114.               begin
  115.                 to_switch := false;
  116.                 ii := jj;
  117.                 return;
  118.               end;
  119.             if ii [k] > jj [k] then
  120.               begin
  121.                 to_switch := true;
  122.                 return;
  123.               end;
  124.           end;
  125.         if ii.len > jj.len then
  126.           begin
  127.             to_switch := true;
  128.             return;
  129.           end;
  130.         if ii.len < jj.len then
  131.           begin
  132.             to_switch := false;
  133.             ii := jj;
  134.             return;
  135.           end;
  136.         for k := 1 to 6 do
  137.           begin
  138.             if ii [k] < jj [k] then
  139.               begin
  140.                 to_switch := false;
  141.                 ii := jj;
  142.                 return;
  143.               end;
  144.             if ii [k] > jj [k] then
  145.               begin
  146.                 to_switch := true;
  147.                 return;
  148.               end;
  149.           end;
  150.         to_switch := false;
  151.         ii := jj;
  152.       end;
  153.           
  154.   begin
  155.     if lines_in < 2 then
  156.       return;
  157.     write   ('Sorting...     ');
  158.     last := lines_in;
  159.     pass := 0;
  160.     repeat
  161.       pass := pass + 1;
  162.       write (chr(8),chr(8),chr(8),chr(8),chr(8),pass:5);
  163.       last := last - 1;
  164.       done := true;
  165.       for i := 1 to last do
  166.         begin
  167.           j := i + 1;
  168.           if to_switch then
  169.             begin
  170.               done  := false;
  171.               ptr   := p [i];
  172.               p [i] := p [j];
  173.               p [j] := ptr;
  174.             end;
  175.         end;
  176.     until done;
  177.     writeln (' sorting passes made.');
  178.   end;
  179.   
  180. procedure write_out;
  181.   var [static]
  182.     i : word;
  183.     j : word;
  184.   begin
  185.     write   ('Writing...     ');
  186.     rewrite (outfile);
  187.     for i := 1 to lines_in do
  188.       begin
  189.         write (chr(8),chr(8),chr(8),chr(8),chr(8),i:5);
  190.         ptr := p [i];
  191.         inline.len := ptr^[0];
  192.         for j := 1 to inline.len do
  193.           inline [j] := chr(ptr^[j]);
  194.         writeln (outfile,inline);
  195.       end;
  196.     close (outfile);
  197.     writeln (' lines written.');
  198.   end;
  199.  
  200. procedure initialize;
  201.   begin
  202.     writeln;
  203.     writeln ('Index sorting program, (C) Copyright Peter Norton 1983');
  204.     writeln;
  205.   end;
  206.   
  207. begin
  208.   initialize;
  209.   read_in;
  210.   sort_data;
  211.   write_out;
  212. end.